home *** CD-ROM | disk | FTP | other *** search
/ Skunkware 5 / Skunkware 5.iso / lib / emacs / 19.22 / lisp / diary.el < prev    next >
Lisp/Scheme  |  1993-10-19  |  91KB  |  1,924 lines
  1. ;;; diary.el --- diary functions.
  2.  
  3. ;; Copyright (C) 1989, 1990, 1992 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Edward M. Reingold <reingold@cs.uiuc.edu>
  6. ;; Keywords: calendar
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is distributed in the hope that it will be useful,
  11. ;; but WITHOUT ANY WARRANTY.  No author or distributor
  12. ;; accepts responsibility to anyone for the consequences of using it
  13. ;; or for whether it serves any particular purpose or works at all,
  14. ;; unless he says so in writing.  Refer to the GNU Emacs General Public
  15. ;; License for full details.
  16.  
  17. ;; Everyone is granted permission to copy, modify and redistribute
  18. ;; GNU Emacs, but only under the conditions described in the
  19. ;; GNU Emacs General Public License.   A copy of this license is
  20. ;; supposed to have been given to you along with GNU Emacs so you
  21. ;; can know your rights and responsibilities.  It should be in a
  22. ;; file named COPYING.  Among other things, the copyright notice
  23. ;; and this notice must be preserved on all copies.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;; This collection of functions implements the diary features as described
  28. ;; in calendar.el.
  29.  
  30. ;; Comments, corrections, and improvements should be sent to
  31. ;;  Edward M. Reingold               Department of Computer Science
  32. ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  33. ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  34. ;;                                   Urbana, Illinois 61801
  35.  
  36. ;;; Code:
  37.  
  38. (require 'calendar)
  39.  
  40. ;;;###autoload
  41. (defun diary (&optional arg)
  42.   "Generate the diary window for ARG days starting with the current date.
  43. If no argument is provided, the number of days of diary entries is governed
  44. by the variable `number-of-diary-entries'.  This function is suitable for
  45. execution in a `.emacs' file."
  46.   (interactive "P")
  47.   (let ((d-file (substitute-in-file-name diary-file))
  48.         (date (calendar-current-date)))
  49.     (if (and d-file (file-exists-p d-file))
  50.         (if (file-readable-p d-file)
  51.             (list-diary-entries
  52.              date
  53.              (cond
  54.               (arg (prefix-numeric-value arg))
  55.               ((vectorp number-of-diary-entries)
  56.                (aref number-of-diary-entries (calendar-day-of-week date)))
  57.               (t number-of-diary-entries)))
  58.         (error "Your diary file is not readable!"))
  59.       (error "You don't have a diary file!"))))
  60.  
  61. (defun view-diary-entries (arg)
  62.   "Prepare and display a buffer with diary entries.
  63. Searches the file named in `diary-file' for entries that
  64. match ARG days starting with the date indicated by the cursor position
  65. in the displayed three-month calendar."
  66.   (interactive "p")
  67.   (let ((d-file (substitute-in-file-name diary-file)))
  68.     (if (and d-file (file-exists-p d-file))
  69.         (if (file-readable-p d-file)
  70.             (list-diary-entries (or (calendar-cursor-to-date)
  71.                                     (error "Cursor is not on a date!"))
  72.                                 arg)
  73.           (error "Your diary file is not readable!"))
  74.       (error "You don't have a diary file!"))))
  75.  
  76. (autoload 'check-calendar-holidays "holidays"
  77.   "Check the list of holidays for any that occur on DATE.
  78. The value returned is a list of strings of relevant holiday descriptions.
  79. The holidays are those in the list `calendar-holidays'."
  80.   t)
  81.  
  82.  
  83. (autoload 'calendar-holiday-list "holidays"
  84.   "Form the list of holidays that occur on dates in the calendar window.
  85. The holidays are those in the list `calendar-holidays'."
  86.   t)
  87.  
  88. (autoload 'diary-french-date "cal-french"
  89.   "French calendar equivalent of date diary entry."
  90.   t)
  91.  
  92. (autoload 'diary-mayan-date "cal-mayan"
  93.   "Mayan calendar equivalent of date diary entry."
  94.   t)
  95.  
  96. (autoload 'diary-phases-of-moon "lunar" "Moon phases diary entry." t)
  97.  
  98. (autoload 'diary-sunrise-sunset "solar"
  99.   "Local time of sunrise and sunset as a diary entry."
  100.   t)
  101.  
  102. (autoload 'diary-sabbath-candles "solar"
  103.   "Local time of candle lighting diary entry--applies if date is a Friday.
  104. No diary entry if there is no sunset on that date."
  105.   t)
  106.  
  107. (defvar diary-syntax-table (copy-syntax-table (standard-syntax-table))
  108.   "The syntax table used when parsing dates in the diary file.
  109. It is the standard syntax table used in Fundamental mode, but with the
  110. syntax of `*' changed to be a word constituent.")
  111.  
  112. (modify-syntax-entry ?* "w" diary-syntax-table)
  113.  
  114. (defun list-diary-entries (date number)
  115.   "Create and display a buffer containing the relevant lines in diary-file.
  116. The arguments are DATE and NUMBER; the entries selected are those
  117. for NUMBER days starting with date DATE.  The other entries are hidden
  118. using selective display.
  119.  
  120. Returns a list of all relevant diary entries found, if any, in order by date.
  121. The list entries have the form ((month day year) string).  If the variable
  122. `diary-list-include-blanks' is t, this list includes a dummy diary entry
  123. \(consisting of the empty string) for a date with no diary entries.
  124.  
  125. After the list is prepared, the hooks `nongregorian-diary-listing-hook',
  126. `list-diary-entries-hook', `diary-display-hook', and `diary-hook' are run.
  127. These hooks have the following distinct roles:
  128.  
  129.     `nongregorian-diary-listing-hook' can cull dates from the diary
  130.         and each included file.  Usually used for Hebrew or Islamic
  131.         diary entries in files.  Applied to *each* file.
  132.  
  133.     `list-diary-entries-hook' adds or manipulates diary entries from
  134.         external sources.  Used, for example, to include diary entries
  135.         from other files or to sort the diary entries.  Invoked *once* only,
  136.         before the display hook is run.
  137.  
  138.     `diary-display-hook' does the actual display of information.  If this is
  139.         nil, simple-diary-display will be used.  Use add-hook to set this to
  140.         fancy-diary-display, if desired.  If you want no diary display, use
  141.         add-hook to set this to ignore.
  142.  
  143.     `diary-hook' is run last.  This can be used for an appointment
  144.         notification function."
  145.  
  146.   (if (< 0 number)
  147.       (let* ((original-date date);; save for possible use in the hooks
  148.              (old-diary-syntax-table)
  149.              (diary-entries-list)
  150.              (date-string (calendar-date-string date))
  151.              (d-file (substitute-in-file-name diary-file)))
  152.         (message "Preparing diary...")
  153.         (save-excursion
  154.           (let ((diary-buffer (get-file-buffer d-file)))
  155.             (set-buffer (if diary-buffer
  156.                             diary-buffer
  157.                          (find-file-noselect d-file t))))
  158.           (setq selective-display t)
  159.           (setq selective-display-ellipses nil)
  160.           (setq old-diary-syntax-table (syntax-table))
  161.           (set-syntax-table diary-syntax-table)
  162.           (unwind-protect
  163.             (let ((buffer-read-only nil)
  164.                   (diary-modified (buffer-modified-p))
  165.                   (mark (regexp-quote diary-nonmarking-symbol)))
  166.               (goto-char (1- (point-max)))
  167.               (if (not (looking-at "\^M\\|\n"))
  168.                   (progn
  169.                     (forward-char 1)
  170.                     (insert-string "\^M")))
  171.               (goto-char (point-min))
  172.               (if (not (looking-at "\^M\\|\n"))
  173.                   (insert-string "\^M"))
  174.               (subst-char-in-region (point-min) (point-max) ?\n ?\^M t)
  175.               (calendar-for-loop i from 1 to number do
  176.                  (let ((d diary-date-forms)
  177.                        (month (extract-calendar-month date))
  178.                        (day (extract-calendar-day date))
  179.                        (year (extract-calendar-year date))
  180.                        (entry-found (list-sexp-diary-entries date)))
  181.                    (while d
  182.                      (let*
  183.                           ((date-form (if (equal (car (car d)) 'backup)
  184.                                           (cdr (car d))
  185.                                         (car d)))
  186.                           (backup (equal (car (car d)) 'backup))
  187.                           (dayname
  188.                            (concat
  189.                             (calendar-day-name date) "\\|"
  190.                             (substring (calendar-day-name date) 0 3) ".?"))
  191.                           (monthname
  192.                            (concat
  193.                             "\\*\\|"
  194.                             (calendar-month-name month) "\\|"
  195.                             (substring (calendar-month-name month) 0 3) ".?"))
  196.                           (month (concat "\\*\\|0*" (int-to-string month)))
  197.                           (day (concat "\\*\\|0*" (int-to-string day)))
  198.                           (year
  199.                            (concat
  200.                             "\\*\\|0*" (int-to-string year)
  201.                             (if abbreviated-calendar-year
  202.                                 (concat "\\|" (int-to-string (% year 100)))
  203.                               "")))
  204.                           (regexp
  205.                            (concat
  206.                             "\\(\\`\\|\^M\\|\n\\)" mark "?\\("
  207.                             (mapconcat 'eval date-form "\\)\\(")
  208.                             "\\)"))
  209.                           (case-fold-search t))
  210.                        (goto-char (point-min))
  211.                        (while (re-search-forward regexp nil t)
  212.                          (if backup (re-search-backward "\\<" nil t))
  213.                          (if (and (or (char-equal (preceding-char) ?\^M)
  214.                                       (char-equal (preceding-char) ?\n))
  215.                                   (not (looking-at " \\|\^I")))
  216.                              ;;  Diary entry that consists only of date.
  217.                              (backward-char 1)
  218.                            ;; Found a nonempty diary entry--make it visible and
  219.                            ;; add it to the list.
  220.                            (setq entry-found t)
  221.                            (let ((entry-start (point))
  222.                                  (date-start))
  223.                              (re-search-backward "\^M\\|\n\\|\\`")
  224.                              (setq date-start (point))
  225.                              (re-search-forward "\^M\\|\n" nil t 2)
  226.                              (while (looking-at " \\|\^I")
  227.                                (re-search-forward "\^M\\|\n" nil t))
  228.                              (backward-char 1)
  229.                              (subst-char-in-region date-start
  230.                                 (point) ?\^M ?\n t)
  231.                              (add-to-diary-list
  232.                                date (buffer-substring entry-start (point)))))))
  233.                      (setq d (cdr d)))
  234.                    (or entry-found
  235.                        (not diary-list-include-blanks)
  236.                        (setq diary-entries-list 
  237.                              (append diary-entries-list
  238.                                      (list (list date "")))))
  239.                    (setq date
  240.                          (calendar-gregorian-from-absolute
  241.                            (1+ (calendar-absolute-from-gregorian date))))
  242.                    (setq entry-found nil)))
  243.               (set-buffer-modified-p diary-modified))
  244.           (set-syntax-table old-diary-syntax-table))
  245.         (goto-char (point-min))
  246.         (run-hooks 'nongregorian-diary-listing-hook
  247.                    'list-diary-entries-hook)
  248.         (if diary-display-hook
  249.             (run-hooks 'diary-display-hook)
  250.           (simple-diary-display))
  251.         (run-hooks 'diary-hook)
  252.         diary-entries-list))))
  253.  
  254. (defun include-other-diary-files ()
  255.   "Include the diary entries from other diary files with those of diary-file.
  256. This function is suitable for use in `list-diary-entries-hook';
  257. it enables you to use shared diary files together with your own.
  258. The files included are specified in the diaryfile by lines of this form:
  259.         #include \"filename\"
  260. This is recursive; that is, #include directives in diary files thus included
  261. are obeyed.  You can change the `#include' to some other string by
  262. changing the variable `diary-include-string'."
  263.   (goto-char (point-min))
  264.   (while (re-search-forward
  265.           (concat
  266.            "\\(\\`\\|\^M\\|\n\\)"
  267.            (regexp-quote diary-include-string)
  268.            " \"\\([^\"]*\\)\"")
  269.           nil t)
  270.     (let ((diary-file (substitute-in-file-name
  271.                        (buffer-substring (match-beginning 2) (match-end 2))))
  272.           (diary-list-include-blanks nil)
  273.           (list-diary-entries-hook 'include-other-diary-files)
  274.           (diary-display-hook 'ignore)
  275.           (diary-hook nil))
  276.       (if (file-exists-p diary-file)
  277.           (if (file-readable-p diary-file)
  278.               (unwind-protect
  279.                   (setq diary-entries-list
  280.                         (append diary-entries-list
  281.                                 (list-diary-entries original-date number)))
  282.                 (kill-buffer (get-file-buffer diary-file)))
  283.             (beep)
  284.             (message "Can't read included diary file %s" diary-file)
  285.             (sleep-for 2))
  286.         (beep)
  287.         (message "Can't find included diary file %s" diary-file)
  288.         (sleep-for 2))))
  289.     (goto-char (point-min)))
  290.  
  291. (defun simple-diary-display ()
  292.   "Display the diary buffer if there are any relevant entries or holidays."
  293.   (let* ((holiday-list (if holidays-in-diary-buffer
  294.                            (check-calendar-holidays original-date)))
  295.          (msg (format "No diary entries for %s %s"
  296.                       (concat date-string (if holiday-list ":" ""))
  297.                       (mapconcat 'identity holiday-list "; "))))
  298.     (if (or (not diary-entries-list)
  299.             (and (not (cdr diary-entries-list))
  300.                  (string-equal (car (cdr (car diary-entries-list))) "")))
  301.         (if (<= (length msg) (frame-width))
  302.             (message msg)
  303.           (set-buffer (get-buffer-create holiday-buffer))
  304.           (setq buffer-read-only nil)
  305.           (calendar-set-mode-line date-string)
  306.           (erase-buffer)
  307.           (insert (mapconcat 'identity holiday-list "\n"))
  308.           (goto-char (point-min))
  309.           (set-buffer-modified-p nil)
  310.           (setq buffer-read-only t)
  311.           (display-buffer holiday-buffer)
  312.           (message  "No diary entries for %s" date-string))
  313.       (calendar-set-mode-line
  314.        (concat "Diary for " date-string
  315.                (if holiday-list ": " "")
  316.                (mapconcat 'identity holiday-list "; ")))
  317.       (display-buffer (get-file-buffer d-file))
  318.       (message "Preparing diary...done"))))
  319.  
  320. (defun fancy-diary-display ()
  321.   "Prepare a diary buffer with relevant entries in a fancy, noneditable form.
  322. This function is provided for optional use as the `diary-display-hook'."
  323.   (if (or (not diary-entries-list)
  324.           (and (not (cdr diary-entries-list))
  325.                (string-equal (car (cdr (car diary-entries-list))) "")))
  326.       (let* ((holiday-list (if holidays-in-diary-buffer
  327.                                (check-calendar-holidays original-date)))
  328.              (msg (format "No diary entries for %s %s"
  329.                           (concat date-string (if holiday-list ":" ""))
  330.                           (mapconcat 'identity holiday-list "; "))))
  331.         (if (<= (length msg) (frame-width))
  332.             (message msg)
  333.           (set-buffer (get-buffer-create holiday-buffer))
  334.           (setq buffer-read-only nil)
  335.           (calendar-set-mode-line date-string)
  336.           (erase-buffer)
  337.           (insert (mapconcat 'identity holiday-list "\n"))
  338.           (goto-char (point-min))
  339.           (set-buffer-modified-p nil)
  340.           (setq buffer-read-only t)
  341.           (display-buffer holiday-buffer)
  342.           (message  "No diary entries for %s" date-string)))
  343.     (save-excursion;; Turn off selective-display in the diary file's buffer.
  344.       (set-buffer (get-file-buffer (substitute-in-file-name diary-file)))
  345.       (let ((diary-modified (buffer-modified-p)))
  346.         (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
  347.         (setq selective-display nil)
  348.         (kill-local-variable 'mode-line-format)
  349.         (set-buffer-modified-p diary-modified)))
  350.     (save-excursion;; Prepare the fancy diary buffer.
  351.       (set-buffer (get-buffer-create fancy-diary-buffer))
  352.       (setq buffer-read-only nil)
  353.       (make-local-variable 'mode-line-format)
  354.       (calendar-set-mode-line "Diary Entries")
  355.       (erase-buffer)
  356.       (let ((entry-list diary-entries-list)
  357.             (holiday-list)
  358.             (holiday-list-last-month 1)
  359.             (holiday-list-last-year 1)
  360.             (date (list 0 0 0)))
  361.         (while entry-list
  362.           (if (not (calendar-date-equal date (car (car entry-list))))
  363.               (progn
  364.                 (setq date (car (car entry-list)))
  365.                 (and holidays-in-diary-buffer
  366.                      (calendar-date-compare
  367.                       (list (list holiday-list-last-month
  368.                                   (calendar-last-day-of-month
  369.                                    holiday-list-last-month
  370.                                    holiday-list-last-year)
  371.                                   holiday-list-last-year))
  372.                       (list date))
  373.                      ;; We need to get the holidays for the next 3 months.
  374.                      (setq holiday-list-last-month
  375.                            (extract-calendar-month date))
  376.                      (setq holiday-list-last-year
  377.                            (extract-calendar-year date))
  378.                      (increment-calendar-month
  379.                       holiday-list-last-month holiday-list-last-year 1)
  380.                      (setq holiday-list
  381.                            (let ((displayed-month holiday-list-last-month)
  382.                                  (displayed-year holiday-list-last-year))
  383.                              (calendar-holiday-list)))
  384.                      (increment-calendar-month
  385.                       holiday-list-last-month holiday-list-last-year 1))
  386.                 (let* ((date-string (calendar-date-string date))
  387.                        (date-holiday-list
  388.                         (let ((h holiday-list)
  389.                               (d))
  390.                           ;; Make a list of all holidays for date.
  391.                           (while h
  392.                             (if (calendar-date-equal date (car (car h)))
  393.                                 (setq d (append d (cdr (car h)))))
  394.                             (setq h (cdr h)))
  395.                           d)))
  396.                   (insert (if (= (point) (point-min)) "" ?\n) date-string)
  397.                   (if date-holiday-list (insert ":  "))
  398.                   (let ((l (current-column)))
  399.                     (insert (mapconcat 'identity date-holiday-list
  400.                                        (concat "\n" (make-string l ? )))))
  401.                   (let ((l (current-column)))
  402.                     (insert ?\n (make-string l ?=) ?\n)))))
  403.           (if (< 0 (length (car (cdr (car entry-list)))))
  404.               (insert (car (cdr (car entry-list))) ?\n))
  405.           (setq entry-list (cdr entry-list))))
  406.       (set-buffer-modified-p nil)
  407.       (goto-char (point-min))
  408.       (setq buffer-read-only t)
  409.       (display-buffer fancy-diary-buffer)
  410.       (message "Preparing diary...done"))))
  411.  
  412. (defun print-diary-entries ()
  413.   "Print a hard copy of the diary display.
  414.  
  415. If the simple diary display is being used, prepare a temp buffer with the
  416. visible lines of the diary buffer, add a heading line composed from the mode
  417. line, print the temp buffer, and destroy it.
  418.  
  419. If the fancy diary display is being used, just print the buffer.
  420.  
  421. The hooks given by the variable `print-diary-entries-hook' are called to do
  422. the actual printing."
  423.   (interactive)
  424.   (if (bufferp (get-buffer fancy-diary-buffer))
  425.       (save-excursion
  426.         (set-buffer (get-buffer fancy-diary-buffer))
  427.         (run-hooks 'print-diary-entries-hook))
  428.     (let ((diary-buffer
  429.            (get-file-buffer (substitute-in-file-name diary-file))))
  430.       (if diary-buffer
  431.           (let ((temp-buffer (get-buffer-create "*Printable Diary Entries*"))
  432.                 (heading))
  433.             (save-excursion
  434.               (set-buffer diary-buffer)
  435.               (setq heading
  436.                     (if (not (stringp mode-line-format))
  437.                         "All Diary Entries"
  438.                       (string-match "^-*\\([^-].*[^-]\\)-*$" mode-line-format)
  439.                       (substring mode-line-format
  440.                                  (match-beginning 1) (match-end 1))))
  441.               (copy-to-buffer temp-buffer (point-min) (point-max))
  442.               (set-buffer temp-buffer)
  443.               (while (re-search-forward "\^M.*$" nil t)
  444.                 (replace-match ""))
  445.               (goto-char (point-min))
  446.               (insert heading "\n"
  447.                       (make-string (length heading) ?=) "\n")
  448.               (run-hooks 'print-diary-entries-hook)
  449.               (kill-buffer temp-buffer)))
  450.         (error "You don't have a diary buffer!")))))
  451.  
  452. (defun show-all-diary-entries ()
  453.   "Show all of the diary entries in the diary file.
  454. This function gets rid of the selective display of the diary file so that
  455. all entries, not just some, are visible.  If there is no diary buffer, one
  456. is created."
  457.   (interactive)
  458.   (let ((d-file (substitute-in-file-name diary-file)))
  459.     (if (and d-file (file-exists-p d-file))
  460.         (if (file-readable-p d-file)
  461.             (save-excursion
  462.               (let ((diary-buffer (get-file-buffer d-file)))
  463.                 (set-buffer (if diary-buffer
  464.                                 diary-buffer
  465.                               (find-file-noselect d-file t)))
  466.                 (let ((buffer-read-only nil)
  467.                       (diary-modified (buffer-modified-p)))
  468.                   (subst-char-in-region (point-min) (point-max) ?\^M ?\n t)
  469.                   (setq selective-display nil)
  470.                   (make-local-variable 'mode-line-format)
  471.                   (setq mode-line-format default-mode-line-format)
  472.                   (display-buffer (current-buffer))
  473.                   (set-buffer-modified-p diary-modified))))
  474.           (error "Your diary file is not readable!"))
  475.       (error "You don't have a diary file!"))))
  476.  
  477. (defun diary-name-pattern (string-array &optional fullname)
  478.   "Convert an STRING-ARRAY, an array of strings to a pattern.
  479. The pattern will match any of the strings, either entirely or abbreviated
  480. to three characters.  An abbreviated form will match with or without a period;
  481. If the optional FULLNAME is t, abbreviations will not match, just the full
  482. name."
  483.   (let ((pattern ""))
  484.     (calendar-for-loop i from 0 to (1- (length string-array)) do
  485.       (setq pattern
  486.             (concat
  487.              pattern
  488.              (if (string-equal pattern "") "" "\\|")
  489.              (aref string-array i)
  490.              (if fullname
  491.                  ""
  492.                (concat
  493.                 "\\|"
  494.                 (substring (aref string-array i) 0 3) ".?")))))
  495.     pattern))
  496.  
  497. (defun mark-diary-entries ()
  498.   "Mark days in the calendar window that have diary entries.
  499. Each entry in the diary file visible in the calendar window is marked.
  500. After the entries are marked, the hooks `nongregorian-diary-marking-hook' and
  501. `mark-diary-entries-hook' are run."
  502.   (interactive)
  503.   (setq mark-diary-entries-in-calendar t)
  504.   (let ((d-file (substitute-in-file-name diary-file)))
  505.     (if (and d-file (file-exists-p d-file))
  506.         (if (file-readable-p d-file)
  507.             (save-excursion
  508.               (message "Marking diary entries...")
  509.               (set-buffer (find-file-noselect d-file t))
  510.               (let ((d diary-date-forms)
  511.                     (old-diary-syntax-table))
  512.                 (setq old-diary-syntax-table (syntax-table))
  513.                 (set-syntax-table diary-syntax-table)
  514.                 (while d
  515.                   (let*
  516.                       ((date-form (if (equal (car (car d)) 'backup)
  517.                                       (cdr (car d))
  518.                                     (car d)));; ignore 'backup directive
  519.                        (dayname (diary-name-pattern calendar-day-name-array))
  520.                        (monthname
  521.                         (concat
  522.                          (diary-name-pattern calendar-month-name-array)
  523.                          "\\|\\*"))
  524.                        (month "[0-9]+\\|\\*")
  525.                        (day "[0-9]+\\|\\*")
  526.                        (year "[0-9]+\\|\\*")
  527.                        (l (length date-form))
  528.                        (d-name-pos (- l (length (memq 'dayname date-form))))
  529.                        (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
  530.                        (m-name-pos (- l (length (memq 'monthname date-form))))
  531.                        (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
  532.                        (d-pos (- l (length (memq 'day date-form))))
  533.                        (d-pos (if (/= l d-pos) (+ 2 d-pos)))
  534.                        (m-pos (- l (length (memq 'month date-form))))
  535.                        (m-pos (if (/= l m-pos) (+ 2 m-pos)))
  536.                        (y-pos (- l (length (memq 'year date-form))))
  537.                        (y-pos (if (/= l y-pos) (+ 2 y-pos)))
  538.                        (regexp
  539.                         (concat
  540.                          "\\(\\`\\|\^M\\|\n\\)\\("
  541.                          (mapconcat 'eval date-form "\\)\\(")
  542.                          "\\)"))
  543.                        (case-fold-search t))
  544.                     (goto-char (point-min))
  545.                     (while (re-search-forward regexp nil t)
  546.                       (let* ((dd-name
  547.                               (if d-name-pos
  548.                                   (buffer-substring
  549.                                    (match-beginning d-name-pos)
  550.                                    (match-end d-name-pos))))
  551.                              (mm-name
  552.                               (if m-name-pos
  553.                                   (buffer-substring
  554.                                    (match-beginning m-name-pos)
  555.                                    (match-end m-name-pos))))
  556.                              (mm (string-to-int
  557.                                   (if m-pos
  558.                                       (buffer-substring
  559.                                        (match-beginning m-pos)
  560.                                        (match-end m-pos))
  561.                                     "")))
  562.                              (dd (string-to-int
  563.                                   (if d-pos
  564.                                       (buffer-substring
  565.                                        (match-beginning d-pos)
  566.                                        (match-end d-pos))
  567.                                     "")))
  568.                              (y-str (if y-pos
  569.                                         (buffer-substring
  570.                                          (match-beginning y-pos)
  571.                                          (match-end y-pos))))
  572.                              (yy (if (not y-str)
  573.                                      0
  574.                                    (if (and (= (length y-str) 2)
  575.                                             abbreviated-calendar-year)
  576.                                        (let* ((current-y
  577.                                                (extract-calendar-year
  578.                                                 (calendar-current-date)))
  579.                                               (y (+ (string-to-int y-str)
  580.                                                     (* 100
  581.                                                        (/ current-y 100)))))
  582.                                          (if (> (- y current-y) 50)
  583.                                              (- y 100)
  584.                                            (if (> (- current-y y) 50)
  585.                                                (+ y 100)
  586.                                              y)))
  587.                                      (string-to-int y-str)))))
  588.                         (if dd-name
  589.                             (mark-calendar-days-named
  590.                              (cdr (assoc (capitalize (substring dd-name 0 3))
  591.                                          (calendar-make-alist
  592.                                           calendar-day-name-array
  593.                                           0
  594.                                           '(lambda (x) (substring x 0 3))))))
  595.                           (if mm-name
  596.                               (if (string-equal mm-name "*")
  597.                                   (setq mm 0)
  598.                                 (setq mm
  599.                                       (cdr (assoc
  600.                                             (capitalize
  601.                                              (substring mm-name 0 3))
  602.                                             (calendar-make-alist
  603.                                              calendar-month-name-array
  604.                                              1
  605.                                              '(lambda (x) (substring x 0 3)))
  606.                                             )))))
  607.                           (mark-calendar-date-pattern mm dd yy))))
  608.                     (setq d (cdr d))))
  609.                 (mark-sexp-diary-entries)
  610.                 (run-hooks 'nongregorian-diary-marking-hook
  611.                            'mark-diary-entries-hook)
  612.                 (set-syntax-table old-diary-syntax-table)
  613.                 (message "Marking diary entries...done")))
  614.           (error "Your diary file is not readable!"))
  615.       (error "You don't have a diary file!"))))
  616.  
  617. (defun mark-sexp-diary-entries ()
  618.   "Mark days in the calendar window that have sexp diary entries.
  619. Each entry in the diary file (or included files) visible in the calendar window
  620. is marked.  See the documentation for the function `list-sexp-diary-entries'."
  621.   (let* ((sexp-mark (regexp-quote sexp-diary-entry-symbol))
  622.          (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" sexp-mark "("))
  623.          (m)
  624.          (y)
  625.          (first-date)
  626.          (last-date))
  627.     (save-excursion
  628.       (set-buffer calendar-buffer)
  629.       (setq m displayed-month)
  630.       (setq y displayed-year))
  631.     (increment-calendar-month m y -1)
  632.     (setq first-date
  633.           (calendar-absolute-from-gregorian (list m 1 y)))
  634.     (increment-calendar-month m y 2)
  635.     (setq last-date
  636.           (calendar-absolute-from-gregorian
  637.            (list m (calendar-last-day-of-month m y) y)))
  638.     (goto-char (point-min))
  639.     (while (re-search-forward s-entry nil t)
  640.       (backward-char 1)
  641.       (let ((sexp-start (point))
  642.             (sexp)
  643.             (entry)
  644.             (entry-start)
  645.             (line-start))
  646.         (forward-sexp)
  647.         (setq sexp (buffer-substring sexp-start (point)))
  648.         (save-excursion
  649.           (re-search-backward "\^M\\|\n\\|\\`")
  650.           (setq line-start (point)))
  651.         (forward-char 1)
  652.         (if (and (or (char-equal (preceding-char) ?\^M)
  653.                      (char-equal (preceding-char) ?\n))
  654.                  (not (looking-at " \\|\^I")))
  655.             (progn;; Diary entry consists only of the sexp
  656.               (backward-char 1)
  657.               (setq entry ""))
  658.           (setq entry-start (point))
  659.           (re-search-forward "\^M\\|\n" nil t)
  660.           (while (looking-at " \\|\^I")
  661.             (re-search-forward "\^M\\|\n" nil t))
  662.           (backward-char 1)
  663.           (setq entry (buffer-substring entry-start (point)))
  664.           (while (string-match "[\^M]" entry)
  665.             (aset entry (match-beginning 0) ?\n )))
  666.         (calendar-for-loop date from first-date to last-date do
  667.           (if (diary-sexp-entry sexp entry
  668.                                 (calendar-gregorian-from-absolute date))
  669.               (mark-visible-calendar-date
  670.                (calendar-gregorian-from-absolute date))))))))
  671.  
  672. (defun mark-included-diary-files ()
  673.   "Mark the diary entries from other diary files with those of the diary file.
  674. This function is suitable for use as the `mark-diary-entries-hook'; it enables
  675. you to use shared diary files together with your own.  The files included are
  676. specified in the diary-file by lines of this form:
  677.         #include \"filename\"
  678. This is recursive; that is, #include directives in diary files thus included
  679. are obeyed.  You can change the `#include' to some other string by
  680. changing the variable `diary-include-string'."
  681.   (goto-char (point-min))
  682.   (while (re-search-forward
  683.           (concat
  684.            "\\(\\`\\|\^M\\|\n\\)"
  685.            (regexp-quote diary-include-string)
  686.            " \"\\([^\"]*\\)\"")
  687.           nil t)
  688.     (let ((diary-file (substitute-in-file-name
  689.                        (buffer-substring (match-beginning 2) (match-end 2))))
  690.           (mark-diary-entries-hook 'mark-included-diary-files))
  691.       (if (file-exists-p diary-file)
  692.           (if (file-readable-p diary-file)
  693.               (progn
  694.                 (mark-diary-entries)
  695.                 (kill-buffer (get-file-buffer diary-file)))
  696.             (beep)
  697.             (message "Can't read included diary file %s" diary-file)
  698.             (sleep-for 2))
  699.         (beep)
  700.         (message "Can't find included diary file %s" diary-file)
  701.         (sleep-for 2))))
  702.   (goto-char (point-min)))
  703.  
  704. (defun mark-calendar-days-named (dayname)
  705.   "Mark all dates in the calendar window that are day DAYNAME of the week.
  706. 0 means all Sundays, 1 means all Mondays, and so on."
  707.   (save-excursion
  708.     (set-buffer calendar-buffer)
  709.     (let ((prev-month displayed-month)
  710.           (prev-year displayed-year)
  711.           (succ-month displayed-month)
  712.           (succ-year displayed-year)
  713.           (last-day)
  714.           (day))
  715.       (increment-calendar-month succ-month succ-year 1)
  716.       (increment-calendar-month prev-month prev-year -1)
  717.       (setq day (calendar-absolute-from-gregorian
  718.                  (calendar-nth-named-day 1 dayname prev-month prev-year)))
  719.       (setq last-day (calendar-absolute-from-gregorian
  720.                  (calendar-nth-named-day -1 dayname succ-month succ-year)))
  721.       (while (<= day last-day)
  722.         (mark-visible-calendar-date (calendar-gregorian-from-absolute day))
  723.         (setq day (+ day 7))))))
  724.  
  725. (defun mark-calendar-date-pattern (month day year)
  726.   "Mark all dates in the calendar window that conform to MONTH/DAY/YEAR.
  727. A value of 0 in any position is a wildcard."
  728.   (save-excursion
  729.     (set-buffer calendar-buffer)
  730.     (let ((m displayed-month)
  731.           (y displayed-year))
  732.       (increment-calendar-month m y -1)
  733.       (calendar-for-loop i from 0 to 2 do
  734.           (mark-calendar-month m y month day year)
  735.           (increment-calendar-month m y 1)))))
  736.  
  737. (defun mark-calendar-month (month year p-month p-day p-year)
  738.   "Mark dates in the MONTH/YEAR that conform to pattern P-MONTH/P_DAY/P-YEAR.
  739. A value of 0 in any position of the pattern is a wildcard."
  740.   (if (or (and (= month p-month)
  741.                (or (= p-year 0) (= year p-year)))
  742.           (and (= p-month 0)
  743.                (or (= p-year 0) (= year p-year))))
  744.       (if (= p-day 0)
  745.           (calendar-for-loop
  746.               i from 1 to (calendar-last-day-of-month month year) do
  747.             (mark-visible-calendar-date (list month i year)))
  748.         (mark-visible-calendar-date (list month p-day year)))))
  749.  
  750. (defun sort-diary-entries ()
  751.   "Sort the list of diary entries by time of day."
  752.   (setq diary-entries-list (sort diary-entries-list 'diary-entry-compare)))
  753.  
  754. (defun diary-entry-compare (e1 e2)
  755.   "Returns t if E1 is earlier than E2."
  756.   (or (calendar-date-compare e1 e2)
  757.       (and (calendar-date-equal (car e1) (car e2))
  758.            (< (diary-entry-time (car (cdr e1)))
  759.               (diary-entry-time (car (cdr e2)))))))
  760.  
  761. (defun diary-entry-time (s)
  762.   "Time at the beginning of the string S in a military-style integer.
  763. For example, returns 1325 for 1:25pm.  Returns -9999 if no time is recognized.
  764. The recognized forms are XXXX or X:XX or XX:XX (military time), XXam or XXpm,
  765. and XX:XXam or XX:XXpm."
  766.   (cond ((string-match;; Military time  
  767.           "^ *\\([0-9]?[0-9]\\):?\\([0-9][0-9]\\)\\(\\>\\|[^ap]\\)" s)
  768.          (+ (* 100 (string-to-int
  769.                     (substring s (match-beginning 1) (match-end 1))))
  770.             (string-to-int (substring s (match-beginning 2) (match-end 2)))))
  771.         ((string-match;; Hour only  XXam or XXpm
  772.           "^ *\\([0-9]?[0-9]\\)\\([ap]\\)m\\>" s)
  773.          (+ (* 100 (% (string-to-int
  774.                          (substring s (match-beginning 1) (match-end 1)))
  775.                         12))
  776.             (if (string-equal "a"
  777.                               (substring s (match-beginning 2) (match-end 2)))
  778.                 0 1200)))
  779.         ((string-match;; Hour and minute  XX:XXam or XX:XXpm
  780.           "^ *\\([0-9]?[0-9]\\):\\([0-9][0-9]\\)\\([ap]\\)m\\>" s)
  781.          (+ (* 100 (% (string-to-int
  782.                          (substring s (match-beginning 1) (match-end 1)))
  783.                         12))
  784.             (string-to-int (substring s (match-beginning 2) (match-end 2)))
  785.             (if (string-equal "a"
  786.                               (substring s (match-beginning 3) (match-end 3)))
  787.                 0 1200)))
  788.         (t -9999)));; Unrecognizable
  789.  
  790. (defun list-hebrew-diary-entries ()
  791.   "Add any Hebrew date entries from the diary file to `diary-entries-list'.
  792. Hebrew date diary entries must be prefaced by `hebrew-diary-entry-symbol'
  793. (normally an `H').  The same diary date forms govern the style of the Hebrew
  794. calendar entries, except that the Hebrew month names must be spelled in full.
  795. The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
  796. Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
  797. common Hebrew year.  If a Hebrew date diary entry begins with a
  798. `diary-nonmarking-symbol', the entry will appear in the diary listing, but will
  799. not be marked in the calendar.  This function is provided for use with the
  800. `nongregorian-diary-listing-hook'."
  801.   (if (< 0 number)
  802.       (let ((buffer-read-only nil)
  803.             (diary-modified (buffer-modified-p))
  804.             (gdate original-date)
  805.             (mark (regexp-quote diary-nonmarking-symbol)))
  806.         (calendar-for-loop i from 1 to number do
  807.            (let* ((d diary-date-forms)
  808.                   (hdate (calendar-hebrew-from-absolute 
  809.                           (calendar-absolute-from-gregorian gdate)))
  810.                   (month (extract-calendar-month hdate))
  811.                   (day (extract-calendar-day hdate))
  812.                   (year (extract-calendar-year hdate)))
  813.              (while d
  814.                (let*
  815.                    ((date-form (if (equal (car (car d)) 'backup)
  816.                                    (cdr (car d))
  817.                                  (car d)))
  818.                     (backup (equal (car (car d)) 'backup))
  819.                     (dayname
  820.                      (concat
  821.                       (calendar-day-name gdate) "\\|"
  822.                       (substring (calendar-day-name gdate) 0 3) ".?"))
  823.                     (calendar-month-name-array
  824.                      calendar-hebrew-month-name-array-leap-year)
  825.                     (monthname
  826.                      (concat
  827.                       "\\*\\|"
  828.                       (calendar-month-name month)))
  829.                     (month (concat "\\*\\|0*" (int-to-string month)))
  830.                     (day (concat "\\*\\|0*" (int-to-string day)))
  831.                     (year
  832.                      (concat
  833.                       "\\*\\|0*" (int-to-string year)
  834.                       (if abbreviated-calendar-year
  835.                           (concat "\\|" (int-to-string (% year 100)))
  836.                         "")))
  837.                     (regexp
  838.                      (concat
  839.                       "\\(\\`\\|\^M\\|\n\\)" mark "?"
  840.                       (regexp-quote hebrew-diary-entry-symbol)
  841.                       "\\("
  842.                       (mapconcat 'eval date-form "\\)\\(")
  843.                       "\\)"))
  844.                     (case-fold-search t))
  845.                  (goto-char (point-min))
  846.                  (while (re-search-forward regexp nil t)
  847.                    (if backup (re-search-backward "\\<" nil t))
  848.                    (if (and (or (char-equal (preceding-char) ?\^M)
  849.                                 (char-equal (preceding-char) ?\n))
  850.                             (not (looking-at " \\|\^I")))
  851.                        ;;  Diary entry that consists only of date.
  852.                        (backward-char 1)
  853.                      ;;  Found a nonempty diary entry--make it visible and
  854.                      ;;  add it to the list.
  855.                      (let ((entry-start (point))
  856.                            (date-start))
  857.                        (re-search-backward "\^M\\|\n\\|\\`")
  858.                        (setq date-start (point))
  859.                        (re-search-forward "\^M\\|\n" nil t 2)
  860.                        (while (looking-at " \\|\^I")
  861.                          (re-search-forward "\^M\\|\n" nil t))
  862.                        (backward-char 1)
  863.                        (subst-char-in-region date-start (point) ?\^M ?\n t)
  864.                        (add-to-diary-list
  865.                          gdate (buffer-substring entry-start (point)))))))
  866.                (setq d (cdr d))))
  867.            (setq gdate
  868.                  (calendar-gregorian-from-absolute
  869.                   (1+ (calendar-absolute-from-gregorian gdate)))))
  870.            (set-buffer-modified-p diary-modified))
  871.         (goto-char (point-min))))
  872.  
  873. (defun mark-hebrew-diary-entries ()
  874.   "Mark days in the calendar window that have Hebrew date diary entries.
  875. Each entry in diary-file (or included files) visible in the calendar window
  876. is marked.  Hebrew date entries are prefaced by a hebrew-diary-entry-symbol
  877. (normally an `H').  The same diary-date-forms govern the style of the Hebrew
  878. calendar entries, except that the Hebrew month names must be spelled in full.
  879. The Hebrew months are numbered from 1 to 13 with Nisan being 1, 12 being
  880. Adar I and 13 being Adar II; you must use `Adar I' if you want Adar of a
  881. common Hebrew year.  Hebrew date diary entries that begin with a
  882. diary-nonmarking symbol will not be marked in the calendar.  This function
  883. is provided for use as part of the nongregorian-diary-marking-hook."
  884.   (let ((d diary-date-forms))
  885.     (while d
  886.       (let*
  887.           ((date-form (if (equal (car (car d)) 'backup)
  888.                           (cdr (car d))
  889.                         (car d)));; ignore 'backup directive
  890.            (dayname (diary-name-pattern calendar-day-name-array))
  891.            (monthname
  892.             (concat
  893.              (diary-name-pattern calendar-hebrew-month-name-array-leap-year t)
  894.              "\\|\\*"))
  895.            (month "[0-9]+\\|\\*")
  896.            (day "[0-9]+\\|\\*")
  897.            (year "[0-9]+\\|\\*")
  898.            (l (length date-form))
  899.            (d-name-pos (- l (length (memq 'dayname date-form))))
  900.            (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
  901.            (m-name-pos (- l (length (memq 'monthname date-form))))
  902.            (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
  903.            (d-pos (- l (length (memq 'day date-form))))
  904.            (d-pos (if (/= l d-pos) (+ 2 d-pos)))
  905.            (m-pos (- l (length (memq 'month date-form))))
  906.            (m-pos (if (/= l m-pos) (+ 2 m-pos)))
  907.            (y-pos (- l (length (memq 'year date-form))))
  908.            (y-pos (if (/= l y-pos) (+ 2 y-pos)))
  909.            (regexp
  910.             (concat
  911.              "\\(\\`\\|\^M\\|\n\\)"
  912.              (regexp-quote hebrew-diary-entry-symbol)
  913.              "\\("
  914.              (mapconcat 'eval date-form "\\)\\(")
  915.              "\\)"))
  916.            (case-fold-search t))
  917.         (goto-char (point-min))
  918.         (while (re-search-forward regexp nil t)
  919.           (let* ((dd-name
  920.                   (if d-name-pos
  921.                       (buffer-substring
  922.                        (match-beginning d-name-pos)
  923.                        (match-end d-name-pos))))
  924.                  (mm-name
  925.                   (if m-name-pos
  926.                       (buffer-substring
  927.                        (match-beginning m-name-pos)
  928.                        (match-end m-name-pos))))
  929.                  (mm (string-to-int
  930.                       (if m-pos
  931.                           (buffer-substring
  932.                            (match-beginning m-pos)
  933.                            (match-end m-pos))
  934.                         "")))
  935.                  (dd (string-to-int
  936.                       (if d-pos
  937.                           (buffer-substring
  938.                            (match-beginning d-pos)
  939.                            (match-end d-pos))
  940.                         "")))
  941.                  (y-str (if y-pos
  942.                             (buffer-substring
  943.                              (match-beginning y-pos)
  944.                              (match-end y-pos))))
  945.                  (yy (if (not y-str)
  946.                          0
  947.                        (if (and (= (length y-str) 2)
  948.                                 abbreviated-calendar-year)
  949.                            (let* ((current-y
  950.                                    (extract-calendar-year
  951.                                     (calendar-hebrew-from-absolute
  952.                                      (calendar-absolute-from-gregorian
  953.                                       (calendar-current-date)))))
  954.                                   (y (+ (string-to-int y-str)
  955.                                         (* 100 (/ current-y 100)))))
  956.                              (if (> (- y current-y) 50)
  957.                                  (- y 100)
  958.                                (if (> (- current-y y) 50)
  959.                                    (+ y 100)
  960.                                  y)))
  961.                          (string-to-int y-str)))))
  962.             (if dd-name
  963.                 (mark-calendar-days-named
  964.                  (cdr (assoc (capitalize (substring dd-name 0 3))
  965.                              (calendar-make-alist
  966.                                calendar-day-name-array
  967.                                0
  968.                               '(lambda (x) (substring x 0 3))))))
  969.               (if mm-name
  970.                   (if (string-equal mm-name "*")
  971.                       (setq mm 0)
  972.                     (setq
  973.                       mm
  974.                       (cdr 
  975.                         (assoc
  976.                           (capitalize mm-name)
  977.                             (calendar-make-alist
  978.                                calendar-hebrew-month-name-array-leap-year))))))
  979.               (mark-hebrew-calendar-date-pattern mm dd yy)))))
  980.       (setq d (cdr d)))))
  981.  
  982. (defun mark-hebrew-calendar-date-pattern (month day year)
  983.   "Mark dates in calendar window that conform to Hebrew date MONTH/DAY/YEAR.
  984. A value of 0 in any position is a wildcard."
  985.   (save-excursion
  986.     (set-buffer calendar-buffer)
  987.     (if (and (/= 0 month) (/= 0 day))
  988.         (if (/= 0 year)
  989.             ;; Fully specified Hebrew date.
  990.             (let ((date (calendar-gregorian-from-absolute
  991.                          (calendar-absolute-from-hebrew
  992.                           (list month day year)))))
  993.               (if (calendar-date-is-visible-p date)
  994.                   (mark-visible-calendar-date date)))
  995.           ;; Month and day in any year--this taken from the holiday stuff.
  996.           (if (memq displayed-month;;  This test is only to speed things up a
  997.                     (list          ;;  bit; it works fine without the test too.
  998.                      (if (< 11 month) (- month 11) (+ month 1))
  999.                      (if (< 10 month) (- month 10) (+ month 2))
  1000.                      (if (<  9 month) (- month  9) (+ month 3))
  1001.                      (if (<  8 month) (- month  8) (+ month 4))
  1002.                      (if (<  7 month) (- month  7) (+ month 5))))
  1003.               (let ((m1 displayed-month)
  1004.                     (y1 displayed-year)
  1005.                     (m2 displayed-month)
  1006.                     (y2 displayed-year)
  1007.                     (year))
  1008.                 (increment-calendar-month m1 y1 -1)
  1009.                 (increment-calendar-month m2 y2 1)
  1010.                 (let* ((start-date (calendar-absolute-from-gregorian
  1011.                                     (list m1 1 y1)))
  1012.                        (end-date (calendar-absolute-from-gregorian
  1013.                                   (list m2
  1014.                                         (calendar-last-day-of-month m2 y2)
  1015.                                         y2)))
  1016.                        (hebrew-start
  1017.                         (calendar-hebrew-from-absolute start-date))
  1018.                        (hebrew-end (calendar-hebrew-from-absolute end-date))
  1019.                        (hebrew-y1 (extract-calendar-year hebrew-start))
  1020.                        (hebrew-y2 (extract-calendar-year hebrew-end)))
  1021.                   (setq year (if (< 6 month) hebrew-y2 hebrew-y1))
  1022.                   (let ((date (calendar-gregorian-from-absolute
  1023.                                (calendar-absolute-from-hebrew
  1024.                                 (list month day year)))))
  1025.                     (if (calendar-date-is-visible-p date)
  1026.                         (mark-visible-calendar-date date)))))))
  1027.       ;; Not one of the simple cases--check all visible dates for match.
  1028.       ;; Actually, the following code takes care of ALL of the cases, but
  1029.       ;; it's much too slow to be used for the simple (common) cases.
  1030.       (let ((m displayed-month)
  1031.             (y displayed-year)
  1032.             (first-date)
  1033.             (last-date))
  1034.         (increment-calendar-month m y -1)
  1035.         (setq first-date
  1036.               (calendar-absolute-from-gregorian
  1037.                (list m 1 y)))
  1038.         (increment-calendar-month m y 2)
  1039.         (setq last-date
  1040.               (calendar-absolute-from-gregorian
  1041.                (list m (calendar-last-day-of-month m y) y)))
  1042.         (calendar-for-loop date from first-date to last-date do
  1043.           (let* ((h-date (calendar-hebrew-from-absolute date))
  1044.                  (h-month (extract-calendar-month h-date))
  1045.                  (h-day (extract-calendar-day h-date))
  1046.                  (h-year (extract-calendar-year h-date)))
  1047.             (and (or (zerop month)
  1048.                      (= month h-month))
  1049.                  (or (zerop day)
  1050.                      (= day h-day))
  1051.                  (or (zerop year)
  1052.                      (= year h-year))
  1053.                  (mark-visible-calendar-date
  1054.                   (calendar-gregorian-from-absolute date)))))))))
  1055.  
  1056. (defun list-sexp-diary-entries (date)
  1057.   "Add sexp entries for DATE from the diary file to `diary-entries-list'.
  1058. Also, Make them visible in the diary file.  Returns t if any entries were
  1059. found.
  1060.  
  1061. Sexp diary entries must be prefaced by a `sexp-diary-entry-symbol' (normally
  1062. `%%').  The form of a sexp diary entry is
  1063.  
  1064.                   %%(SEXP) ENTRY
  1065.  
  1066. Both ENTRY and DATE are globally available when the SEXP is evaluated.  If the
  1067. SEXP yields the value nil, the diary entry does not apply.  If it yields a
  1068. non-nil value, ENTRY will be taken to apply to DATE; if the non-nil value is a
  1069. string, that string will be the diary entry in the fancy diary display.
  1070.  
  1071. For example, the following diary entry will apply to the 21st of the month
  1072. if it is a weekday and the Friday before if the 21st is on a weekend:
  1073.  
  1074.       &%%(let ((dayname (calendar-day-of-week date))
  1075.                (day (extract-calendar-day date)))
  1076.            (or
  1077.              (and (= day 21) (memq dayname '(1 2 3 4 5)))
  1078.              (and (memq day '(19 20)) (= dayname 5)))
  1079.          ) UIUC pay checks deposited
  1080.  
  1081. A number of built-in functions are available for this type of diary entry:
  1082.  
  1083.       %%(diary-float MONTH DAYNAME N) text
  1084.                   Entry will appear on the Nth DAYNAME of MONTH.
  1085.                   (DAYNAME=0 means Sunday, 1 means Monday, and so on;
  1086.                   if N is negative it counts backward from the end of
  1087.                   the month.  MONTH can be a list of months, a single
  1088.                   month, or t to specify all months.
  1089.  
  1090.       %%(diary-block M1 D1 Y1 M2 D2 Y2) text
  1091.                   Entry will appear on dates between M1/D1/Y1 and M2/D2/Y2,
  1092.                   inclusive.  (If `european-calendar-style' is t, the
  1093.                   order of the parameters should be changed to D1, M1, Y1,
  1094.                   D2, M2, Y2.)
  1095.  
  1096.       %%(diary-anniversary MONTH DAY YEAR) text
  1097.                   Entry will appear on anniversary dates of MONTH DAY, YEAR.
  1098.                   (If `european-calendar-style' is t, the order of the
  1099.                   parameters should be changed to DAY, MONTH, YEAR.)  Text
  1100.                   can contain %d or %d%s; %d will be replaced by the number
  1101.                   of years since the MONTH DAY, YEAR and %s will be replaced
  1102.                   by the ordinal ending of that number (that is, `st', `nd',
  1103.                   `rd' or `th', as appropriate.  The anniversary of February
  1104.                   29 is considered to be March 1 in a non-leap year.
  1105.  
  1106.       %%(diary-cyclic N MONTH DAY YEAR) text
  1107.                   Entry will appear every N days, starting MONTH DAY, YEAR.
  1108.                   (If `european-calendar-style' is t, the order of the
  1109.                   parameters should be changed to N, DAY, MONTH, YEAR.)  Text
  1110.                   can contain %d or %d%s; %d will be replaced by the number
  1111.                   of repetitions since the MONTH DAY, YEAR and %s will
  1112.                   be replaced by the ordinal ending of that number (that is,
  1113.                   `st', `nd', `rd' or `th', as appropriate.
  1114.  
  1115.       %%(diary-day-of-year)
  1116.                   Diary entries giving the day of the year and the number of
  1117.                   days remaining in the year will be made every day.  Note
  1118.                   that since there is no text, it makes sense only if the
  1119.                   fancy diary display is used.
  1120.  
  1121.       %%(diary-iso-date)
  1122.                   Diary entries giving the corresponding ISO commercial date
  1123.                   will be made every day.  Note that since there is no text,
  1124.                   it makes sense only if the fancy diary display is used.
  1125.  
  1126.       %%(diary-french-date)
  1127.                   Diary entries giving the corresponding French Revolutionary
  1128.                   date will be made every day.  Note that since there is no
  1129.                   text, it makes sense only if the fancy diary display is used.
  1130.  
  1131.       %%(diary-islamic-date)
  1132.                   Diary entries giving the corresponding Islamic date will be
  1133.                   made every day.  Note that since there is no text, it
  1134.                   makes sense only if the fancy diary display is used.
  1135.  
  1136.       %%(diary-hebrew-date)
  1137.                   Diary entries giving the corresponding Hebrew date will be
  1138.                   made every day.  Note that since there is no text, it
  1139.                   makes sense only if the fancy diary display is used.
  1140.  
  1141.       %%(diary-astro-day-number) Diary entries giving the corresponding
  1142.                   astronomical (Julian) day number will be made every day.
  1143.                   Note that since there is no text, it makes sense only if the
  1144.                   fancy diary display is used.
  1145.  
  1146.       %%(diary-julian-date) Diary entries giving the corresponding
  1147.                  Julian date will be made every day.  Note that since
  1148.                  there is no text, it makes sense only if the fancy diary
  1149.                  display is used.
  1150.  
  1151.       %%(diary-sunrise-sunset)
  1152.                   Diary entries giving the local times of sunrise and sunset
  1153.                   will be made every day.  Note that since there is no text,
  1154.                   it makes sense only if the fancy diary display is used.
  1155.                   Floating point required.
  1156.  
  1157.       %%(diary-phases-of-moon)
  1158.                   Diary entries giving the times of the phases of the moon
  1159.                   will be when appropriate.  Note that since there is no text,
  1160.                   it makes sense only if the fancy diary display is used.
  1161.                   Floating point required.
  1162.  
  1163.       %%(diary-yahrzeit MONTH DAY YEAR) text
  1164.                   Text is assumed to be the name of the person; the date is
  1165.                   the date of death on the *civil* calendar.  The diary entry
  1166.                   will appear on the proper Hebrew-date anniversary and on the
  1167.                   day before.  (If `european-calendar-style' is t, the order
  1168.                   of the parameters should be changed to DAY, MONTH, YEAR.)
  1169.                   
  1170.       %%(diary-rosh-hodesh)
  1171.                   Diary entries will be made on the dates of Rosh Hodesh on
  1172.                   the Hebrew calendar.  Note that since there is no text, it
  1173.                   makes sense only if the fancy diary display is used.
  1174.  
  1175.       %%(diary-parasha)
  1176.                   Diary entries giving the weekly parasha will be made on
  1177.                   every Saturday.  Note that since there is no text, it
  1178.                   makes sense only if the fancy diary display is used.
  1179.  
  1180.       %%(diary-omer)
  1181.                   Diary entries giving the omer count will be made every day
  1182.                   from Passover to Shavuoth.  Note that since there is no text,
  1183.                   it makes sense only if the fancy diary display is used.
  1184.  
  1185. Marking these entries is *extremely* time consuming, so these entries are
  1186. best if they are nonmarking."
  1187.   (let* ((mark (regexp-quote diary-nonmarking-symbol))
  1188.          (sexp-mark (regexp-quote sexp-diary-entry-symbol))
  1189.          (s-entry (concat "\\(\\`\\|\^M\\|\n\\)" mark "?" sexp-mark "("))
  1190.          (entry-found))
  1191.     (goto-char (point-min))
  1192.     (while (re-search-forward s-entry nil t)
  1193.       (backward-char 1)
  1194.       (let ((sexp-start (point))
  1195.             (sexp)
  1196.             (entry)
  1197.             (entry-start)
  1198.             (line-start))
  1199.         (forward-sexp)
  1200.         (setq sexp (buffer-substring sexp-start (point)))
  1201.         (save-excursion
  1202.           (re-search-backward "\^M\\|\n\\|\\`")
  1203.           (setq line-start (point)))
  1204.         (forward-char 1)
  1205.         (if (and (or (char-equal (preceding-char) ?\^M)
  1206.                      (char-equal (preceding-char) ?\n))
  1207.                  (not (looking-at " \\|\^I")))
  1208.             (progn;; Diary entry consists only of the sexp
  1209.               (backward-char 1)
  1210.               (setq entry ""))
  1211.           (setq entry-start (point))
  1212.           (re-search-forward "\^M\\|\n" nil t)
  1213.           (while (looking-at " \\|\^I")
  1214.             (re-search-forward "\^M\\|\n" nil t))
  1215.           (backward-char 1)
  1216.           (setq entry (buffer-substring entry-start (point)))
  1217.           (while (string-match "[\^M]" entry)
  1218.             (aset entry (match-beginning 0) ?\n )))
  1219.         (let ((diary-entry (diary-sexp-entry sexp entry date)))
  1220.           (if diary-entry
  1221.               (subst-char-in-region line-start (point) ?\^M ?\n t))
  1222.           (add-to-diary-list date diary-entry)
  1223.           (setq entry-found (or entry-found diary-entry)))))
  1224.     entry-found))
  1225.  
  1226. (defun diary-sexp-entry (sexp entry date)
  1227.   "Process a SEXP diary ENTRY for DATE."
  1228.   (let ((result (if calendar-debug-sexp
  1229.                   (let ((stack-trace-on-error t))
  1230.                     (eval (car (read-from-string sexp))))
  1231.                   (condition-case nil
  1232.                       (eval (car (read-from-string sexp)))
  1233.                     (error
  1234.                      (beep)
  1235.                      (message "Bad sexp at line %d in %s: %s"
  1236.                               (save-excursion
  1237.                                 (save-restriction
  1238.                                   (narrow-to-region 1 (point))
  1239.                                   (goto-char (point-min))
  1240.                                   (let ((lines 1))
  1241.                                     (while (re-search-forward "\n\\|\^M" nil t)
  1242.                                       (setq lines (1+ lines)))
  1243.                                     lines)))
  1244.                               diary-file sexp)
  1245.                      (sleep-for 2))))))
  1246.     (if (stringp result)
  1247.         result
  1248.       (if result
  1249.           entry
  1250.         nil))))
  1251.  
  1252. (defun diary-block (m1 d1 y1 m2 d2 y2)
  1253.   "Block diary entry.
  1254. Entry applies if date is between two dates.  Order of the parameters is
  1255. M1, D1, Y1, M2, D2, Y2 `european-calendar-style' is nil, and
  1256. D1, M1, Y1, D2, M2, Y2 if `european-calendar-style' is t."
  1257.   (let ((date1 (calendar-absolute-from-gregorian
  1258.                 (if european-calendar-style
  1259.                     (list d1 m1 y1)
  1260.                   (list m1 d1 y1))))
  1261.         (date2 (calendar-absolute-from-gregorian
  1262.                 (if european-calendar-style
  1263.                     (list d2 m2 y2)
  1264.                   (list m2 d2 y2))))
  1265.         (d (calendar-absolute-from-gregorian date)))
  1266.     (if (and (<= date1 d) (<= d date2))
  1267.         entry)))
  1268.  
  1269. (defun diary-float (month dayname n)
  1270.   "Floating diary entry--entry applies if date is the nth dayname of month.
  1271. Parameters are MONTH, DAYNAME, N.  MONTH can be a list of months, the constant
  1272. t, or an integer.  The constant t means all months.  If N is negative, count
  1273. backward from the end of the month."
  1274.   (let ((m (extract-calendar-month date))
  1275.         (y (extract-calendar-year date)))
  1276.     (if (and
  1277.          (or (and (listp month) (memq m month))
  1278.              (equal m month)
  1279.              (eq month t))
  1280.          (calendar-date-equal date (calendar-nth-named-day n dayname m y)))
  1281.         entry)))
  1282.  
  1283. (defun diary-anniversary (month day year)
  1284.   "Anniversary diary entry.
  1285. Entry applies if date is the anniversary of MONTH, DAY, YEAR if
  1286. `european-calendar-style' is nil, and DAY, MONTH, YEAR if
  1287. `european-calendar-style' is t.  Diary entry can contain `%d' or `%d%s'; the
  1288. %d will be replaced by the number of years since the MONTH DAY, YEAR and the
  1289. %s will be replaced by the ordinal ending of that number (that is, `st', `nd',
  1290. `rd' or `th', as appropriate.  The anniversary of February 29 is considered
  1291. to be March 1 in non-leap years."
  1292.   (let* ((d (if european-calendar-style
  1293.                 month
  1294.               day))
  1295.          (m (if european-calendar-style
  1296.                 day
  1297.               month))
  1298.          (y (extract-calendar-year date))
  1299.          (diff (- y year)))
  1300.     (if (and (= m 2) (= d 29) (not (calendar-leap-year-p y)))
  1301.         (setq m 3
  1302.               d 1))
  1303.     (if (and (> diff 0) (calendar-date-equal (list m d y) date))
  1304.         (format entry diff (diary-ordinal-suffix diff)))))
  1305.  
  1306. (defun diary-cyclic (n month day year)
  1307.   "Cycle diary entry--entry applies every N days starting at MONTH, DAY, YEAR.
  1308. If `european-calendar-style' is t, parameters are N, DAY, MONTH, YEAR.
  1309. ENTRY can contain `%d' or `%d%s'; the %d will be replaced by the number of
  1310. years since the MONTH DAY, YEAR and the %s will be replaced by the ordinal
  1311. ending of that number (that is, `st', `nd', `rd' or `th', as appropriate."
  1312.   (let* ((d (if european-calendar-style
  1313.                 month
  1314.               day))
  1315.          (m (if european-calendar-style
  1316.                 day
  1317.               month))
  1318.          (diff (- (calendar-absolute-from-gregorian date)
  1319.                   (calendar-absolute-from-gregorian
  1320.                    (list m d year))))
  1321.          (cycle (/ diff n)))
  1322.     (if (and (>= diff 0) (zerop (% diff n)))
  1323.         (format entry cycle (diary-ordinal-suffix cycle)))))
  1324.  
  1325. (defun diary-ordinal-suffix (n)
  1326.   "Ordinal suffix for N. (That is, `st', `nd', `rd', or `th', as appropriate.)"
  1327.   (if (or (memq (% n 100) '(11 12 13))
  1328.       (< 3 (% n 10)))
  1329.       "th"
  1330.     (aref ["th" "st" "nd" "rd"] (% n 10))))
  1331.  
  1332. (defun diary-day-of-year ()
  1333.   "Day of year and number of days remaining in the year of date diary entry."
  1334.   (let* ((year (extract-calendar-year date))
  1335.          (day (calendar-day-number date))
  1336.          (days-remaining (- (calendar-day-number (list 12 31 year)) day)))
  1337.     (format "Day %d of %d; %d day%s remaining in the year"
  1338.              day year days-remaining (if (= days-remaining 1) "" "s"))))
  1339.  
  1340. (defun diary-iso-date ()
  1341.   "ISO calendar equivalent of date diary entry."
  1342.   (let ((day (% (calendar-absolute-from-gregorian date) 7))
  1343.         (iso-date (calendar-iso-from-absolute
  1344.                    (calendar-absolute-from-gregorian date))))
  1345.     (format "ISO date: Day %s of week %d of %d."
  1346.             (if (zerop day) 7 day)
  1347.             (extract-calendar-month iso-date)
  1348.             (extract-calendar-year iso-date))))
  1349.  
  1350. (defun diary-islamic-date ()
  1351.   "Islamic calendar equivalent of date diary entry."
  1352.   (let* ((i-date (calendar-islamic-from-absolute
  1353.                   (calendar-absolute-from-gregorian date)))
  1354.          (calendar-month-name-array calendar-islamic-month-name-array))
  1355.     (if (>= (extract-calendar-year i-date) 1)
  1356.         (format "Islamic date: %s" (calendar-date-string i-date nil t)))))
  1357.  
  1358. (defun diary-hebrew-date ()
  1359.   "Hebrew calendar equivalent of date diary entry."
  1360.   (let* ((h-date (calendar-hebrew-from-absolute
  1361.                   (calendar-absolute-from-gregorian date)))
  1362.          (calendar-month-name-array
  1363.           (if (hebrew-calendar-leap-year-p
  1364.                (extract-calendar-year h-date))
  1365.               calendar-hebrew-month-name-array-leap-year
  1366.             calendar-hebrew-month-name-array-common-year)))
  1367.     (format "Hebrew date: %s" (calendar-date-string h-date nil t))))
  1368.  
  1369. (defun diary-julian-date ()
  1370.   "Julian calendar equivalent of date diary entry."
  1371.   (format "Julian date: %s"
  1372.           (calendar-date-string
  1373.            (calendar-julian-from-absolute
  1374.             (calendar-absolute-from-gregorian date)))
  1375.           nil t))
  1376.  
  1377. (defun diary-astro-day-number ()
  1378.   "Astronomical (Julian) day number diary entry."
  1379.   (format "Astronomical (Julian) day number %d"
  1380.           (+ 1721425 (calendar-absolute-from-gregorian date))))
  1381.  
  1382. (defun diary-omer ()
  1383.   "Omer count diary entry.
  1384. Entry applies if date is within 50 days after Passover."
  1385.   (let* ((passover
  1386.           (calendar-absolute-from-hebrew
  1387.            (list 1 15 (+ (extract-calendar-year date) 3760))))
  1388.          (omer (- (calendar-absolute-from-gregorian date) passover))
  1389.          (week (/ omer 7))
  1390.          (day (% omer 7)))
  1391.     (if (and (> omer 0) (< omer 50))
  1392.         (format "Day %d%s of the omer (until sunset)"
  1393.                 omer
  1394.                 (if (zerop week)
  1395.                     ""
  1396.                   (format ", that is, %d week%s%s"
  1397.                           week
  1398.                           (if (= week 1) "" "s")
  1399.                           (if (zerop day)
  1400.                               ""
  1401.                             (format " and %d day%s"
  1402.                                     day (if (= day 1) "" "s")))))))))
  1403.  
  1404. (defun diary-yahrzeit (death-month death-day death-year)
  1405.   "Yahrzeit diary entry--entry applies if date is yahrzeit or the day before.
  1406. Parameters are DEATH-MONTH, DEATH-DAY, DEATH-YEAR; the diary entry is assumed
  1407. to be the name of the person.  Date of death is on the *civil* calendar;
  1408. although the date of death is specified by the civil calendar, the proper
  1409. Hebrew calendar yahrzeit is determined.  If `european-calendar-style' is t, the
  1410. order of the parameters is changed to DEATH-DAY, DEATH-MONTH, DEATH-YEAR."
  1411.   (let* ((h-date (calendar-hebrew-from-absolute
  1412.                   (calendar-absolute-from-gregorian
  1413.                    (if european-calendar-style
  1414.                        (list death-day death-month death-year)
  1415.                    (list death-month death-day death-year)))))
  1416.          (h-month (extract-calendar-month h-date))
  1417.          (h-day (extract-calendar-day h-date))
  1418.          (h-year (extract-calendar-year h-date))
  1419.          (d (calendar-absolute-from-gregorian date))
  1420.          (yr (extract-calendar-year (calendar-hebrew-from-absolute d)))
  1421.          (diff (- yr h-year))
  1422.          (y (hebrew-calendar-yahrzeit h-date yr)))
  1423.     (if (and (> diff 0) (or (= y d) (= y (1+ d))))
  1424.         (format "Yahrzeit of %s%s: %d%s anniversary"
  1425.                 entry
  1426.                 (if (= y d) "" " (evening)")
  1427.                 diff
  1428.                 (cond ((= (% diff 10) 1) "st")
  1429.                       ((= (% diff 10) 2) "nd")
  1430.                       ((= (% diff 10) 3) "rd")
  1431.                       (t "th"))))))
  1432.  
  1433. (defun diary-rosh-hodesh ()
  1434.   "Rosh Hodesh diary entry.
  1435. Entry applies if date is Rosh Hodesh, the day before, or the Saturday before."
  1436.   (let* ((d (calendar-absolute-from-gregorian date))
  1437.          (h-date (calendar-hebrew-from-absolute d))
  1438.          (h-month (extract-calendar-month h-date))
  1439.          (h-day (extract-calendar-day h-date))
  1440.          (h-year (extract-calendar-year h-date))
  1441.          (leap-year (hebrew-calendar-leap-year-p h-year))
  1442.          (last-day (hebrew-calendar-last-day-of-month h-month h-year))
  1443.          (h-month-names
  1444.           (if leap-year
  1445.               calendar-hebrew-month-name-array-leap-year
  1446.             calendar-hebrew-month-name-array-common-year))
  1447.          (this-month (aref h-month-names (1- h-month)))
  1448.          (h-yesterday (extract-calendar-day
  1449.                        (calendar-hebrew-from-absolute (1- d)))))
  1450.     (if (or (= h-day 30) (and (= h-day 1) (/= h-month 7)))
  1451.         (format
  1452.          "Rosh Hodesh %s"
  1453.          (if (= h-day 30)
  1454.              (format
  1455.               "%s (first day)"
  1456.               ;; next month must be in the same year since this
  1457.               ;; month can't be the last month of the year since
  1458.               ;; it has 30 days
  1459.               (aref h-month-names h-month))
  1460.            (if (= h-yesterday 30)
  1461.                (format "%s (second day)" this-month)
  1462.              this-month)))
  1463.       (if (= (% d 7) 6);; Saturday--check for Shabbat Mevarhim
  1464.           (cond ((and (> h-day 22) (/= h-month 6) (= 29 last-day))
  1465.                  (format "Mevarhim Rosh Hodesh %s (%s)"
  1466.                          (aref h-month-names
  1467.                                (if (= h-month
  1468.                                       (hebrew-calendar-last-month-of-year
  1469.                                        h-year))
  1470.                                    0 h-month))
  1471.                          (aref calendar-day-name-array (- 29 h-day))))
  1472.                 ((and (< h-day 30) (> h-day 22) (= 30 last-day))
  1473.                  (format "Mevarhim Rosh Hodesh %s (%s-%s)"
  1474.                          (aref h-month-names h-month)
  1475.                          (if (= h-day 29)
  1476.                              "tomorrow"
  1477.                            (aref calendar-day-name-array (- 29 h-day)))
  1478.                          (aref calendar-day-name-array
  1479.                                (% (- 30 h-day) 7)))))
  1480.         (if (and (= h-day 29) (/= h-month 6))
  1481.             (format "Erev Rosh Hodesh %s"
  1482.                     (aref h-month-names
  1483.                           (if (= h-month
  1484.                                  (hebrew-calendar-last-month-of-year
  1485.                                   h-year))
  1486.                               0 h-month))))))))
  1487.  
  1488. (defun diary-parasha ()
  1489.   "Parasha diary entry--entry applies if date is a Saturday."
  1490.   (let ((d (calendar-absolute-from-gregorian date)))
  1491.     (if (= (% d 7) 6);;  Saturday
  1492.         (let*
  1493.             ((h-year (extract-calendar-year
  1494.                       (calendar-hebrew-from-absolute d)))
  1495.              (rosh-hashannah
  1496.               (calendar-absolute-from-hebrew (list 7 1 h-year)))
  1497.              (passover
  1498.               (calendar-absolute-from-hebrew (list 1 15 h-year)))
  1499.              (rosh-hashannah-day
  1500.               (aref calendar-day-name-array (% rosh-hashannah 7)))
  1501.              (passover-day
  1502.               (aref calendar-day-name-array (% passover 7)))
  1503.              (long-h (hebrew-calendar-long-heshvan-p h-year))
  1504.              (short-k (hebrew-calendar-short-kislev-p h-year))
  1505.              (type (cond ((and long-h (not short-k)) "complete")
  1506.                          ((and (not long-h) short-k) "incomplete")
  1507.                          (t "regular")))
  1508.              (year-format
  1509.               (symbol-value
  1510.                (intern (format "hebrew-calendar-year-%s-%s-%s";; keviah
  1511.                                rosh-hashannah-day type passover-day))))
  1512.              (first-saturday;; of Hebrew year
  1513.               (calendar-dayname-on-or-before 6 (+ 6 rosh-hashannah)))
  1514.              (saturday;; which Saturday of the Hebrew year
  1515.               (/ (- d first-saturday) 7))
  1516.              (parasha (aref year-format saturday)))
  1517.           (if parasha
  1518.               (format
  1519.                "Parashat %s"
  1520.                (if (listp parasha);; Israel differs from diaspora
  1521.                    (if (car parasha)
  1522.                        (format "%s (diaspora), %s (Israel)"
  1523.                                (hebrew-calendar-parasha-name (car parasha))
  1524.                                (hebrew-calendar-parasha-name (cdr parasha)))
  1525.                      (format "%s (Israel)"
  1526.                              (hebrew-calendar-parasha-name (cdr parasha))))
  1527.                  (hebrew-calendar-parasha-name parasha))))))))
  1528.  
  1529. (defun add-to-diary-list (date string)
  1530.   "Add the entry (DATE STRING) to `diary-entries-list'.
  1531. Do nothing if DATE or STRING is nil."
  1532.   (and date string
  1533.        (setq diary-entries-list 
  1534.              (append diary-entries-list (list (list date string))))))
  1535.  
  1536. (defvar hebrew-calendar-parashiot-names
  1537. ["Bereshith"   "Noah"      "Lech L'cha" "Vayera"    "Hayei Sarah" "Toledoth"
  1538.  "Vayetze"     "Vayishlah" "Vayeshev"   "Mikketz"   "Vayiggash"   "Vayhi"
  1539.  "Shemoth"     "Vaera"     "Bo"         "Beshallah" "Yithro"      "Mishpatim"
  1540.  "Terumah"     "Tetzavveh" "Ki Tissa"   "Vayakhel"  "Pekudei"     "Vayikra"
  1541.  "Tzav"        "Shemini"   "Tazria"     "Metzora"   "Aharei Moth" "Kedoshim"
  1542.  "Emor"        "Behar"     "Behukkotai" "Bemidbar"  "Naso"       "Behaalot'cha"
  1543.  "Shelah L'cha" "Korah"    "Hukkath"    "Balak"     "Pinhas"      "Mattoth"
  1544.  "Masei"       "Devarim"   "Vaethanan"  "Ekev"      "Reeh"        "Shofetim"
  1545.  "Ki Tetze"    "Ki Tavo"   "Nitzavim"   "Vayelech"  "Haazinu"]
  1546.   "The names of the parashiot in the Torah.")
  1547.  
  1548. ;; The seven ordinary year types (keviot)
  1549.  
  1550. (defconst hebrew-calendar-year-Saturday-incomplete-Sunday
  1551.   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1552.     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
  1553.     43 44 45 46 47 48 49 50]
  1554.   "The structure of the parashiot.
  1555. Hebrew year starts on Saturday, is `incomplete' (Heshvan and Kislev each have
  1556. 29 days), and has Passover start on Sunday.")
  1557.  
  1558. (defconst hebrew-calendar-year-Saturday-complete-Tuesday
  1559.   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1560.     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
  1561.     43 44 45 46 47 48 49 [50 51]]
  1562.   "The structure of the parashiot.
  1563. Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
  1564. have 30 days), and has Passover start on Tuesday.")
  1565.  
  1566. (defconst hebrew-calendar-year-Monday-incomplete-Tuesday
  1567.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1568.     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
  1569.     43 44 45 46 47 48 49 [50 51]]
  1570.   "The structure of the parashiot.
  1571. Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
  1572. have 29 days), and has Passover start on Tuesday.")
  1573.  
  1574. (defconst hebrew-calendar-year-Monday-complete-Thursday
  1575.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1576.    23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
  1577.    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
  1578.   "The structure of the parashiot.
  1579. Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
  1580. 30 days), and has Passover start on Thursday.")
  1581.  
  1582. (defconst hebrew-calendar-year-Tuesday-regular-Thursday
  1583.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22]
  1584.    23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 (nil . 34) (34 . 35) (35 . 36)
  1585.    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
  1586.   "The structure of the parashiot.
  1587. Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
  1588. Kislev has 30 days), and has Passover start on Thursday.")
  1589.  
  1590. (defconst hebrew-calendar-year-Thursday-regular-Saturday
  1591.   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 [21 22] 23
  1592.    24 nil (nil . 25) (25 . [26 27]) ([26 27] . [28 29]) ([28 29] . 30)
  1593.    (30 . 31) ([31 32] . 32) 33 34 35 36 37 38 39 40 [41 42] 43 44 45 46 47 48
  1594.    49 50]
  1595.   "The structure of the parashiot.
  1596. Hebrew year that starts on Thursday, is `regular' (Heshvan has 29 days and
  1597. Kislev has 30 days), and has Passover start on Saturday.")
  1598.  
  1599. (defconst hebrew-calendar-year-Thursday-complete-Sunday
  1600.   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1601.     23 24 nil 25 [26 27] [28 29] 30 [31 32] 33 34 35 36 37 38 39 40 [41 42]
  1602.     43 44 45 46 47 48 49 50]
  1603.   "The structure of the parashiot.
  1604. Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev each
  1605. have 30 days), and has Passover start on Sunday.")
  1606.  
  1607. ;; The seven leap year types (keviot)
  1608.  
  1609. (defconst hebrew-calendar-year-Saturday-incomplete-Tuesday
  1610.   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1611.     23 24 25 26 27 nil 28 29 30 31 32 33 34 35 36 37 38 39 40 [41 42]
  1612.     43 44 45 46 47 48 49 [50 51]]
  1613.   "The structure of the parashiot.
  1614. Hebrew year that starts on Saturday, is `incomplete' (Heshvan and Kislev each
  1615. have 29 days), and has Passover start on Tuesday.")
  1616.  
  1617. (defconst hebrew-calendar-year-Saturday-complete-Thursday
  1618.   [nil 52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1619.    23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
  1620.    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
  1621.   "The structure of the parashiot.
  1622. Hebrew year that starts on Saturday, is `complete' (Heshvan and Kislev each
  1623. have 30 days), and has Passover start on Thursday.")
  1624.  
  1625. (defconst hebrew-calendar-year-Monday-incomplete-Thursday
  1626.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1627.    23 24 25 26 27 nil 28 29 30 31 32 33 (nil . 34) (34 . 35) (35 . 36)
  1628.    (36 . 37) (37 . 38) ([38 39] . 39) 40 [41 42] 43 44 45 46 47 48 49 [50 51]]
  1629.   "The structure of the parashiot.
  1630. Hebrew year that starts on Monday, is `incomplete' (Heshvan and Kislev each
  1631. have 29 days), and has Passover start on Thursday.")
  1632.  
  1633. (defconst hebrew-calendar-year-Monday-complete-Saturday
  1634.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1635.    23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
  1636.    (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
  1637.    (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
  1638.   "The structure of the parashiot.
  1639. Hebrew year that starts on Monday, is `complete' (Heshvan and Kislev each have
  1640. 30 days), and has Passover start on Saturday.")
  1641.  
  1642. (defconst hebrew-calendar-year-Tuesday-regular-Saturday
  1643.   [51 52 nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1644.    23 24 25 26 27 nil (nil . 28) (28 . 29) (29 . 30) (30 . 31) (31 . 32)
  1645.    (32 . 33) (33 . 34) (34 . 35) (35 . 36) (36 . 37) (37 . 38) (38 . 39)
  1646.    (39 . 40) (40 . 41) ([41 42] . 42) 43 44 45 46 47 48 49 50]
  1647.   "The structure of the parashiot.
  1648. Hebrew year that starts on Tuesday, is `regular' (Heshvan has 29 days and
  1649. Kislev has 30 days), and has Passover start on Saturday.")
  1650.  
  1651. (defconst hebrew-calendar-year-Thursday-incomplete-Sunday
  1652.   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1653.     23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
  1654.     43 44 45 46 47 48 49 50]
  1655.   "The structure of the parashiot.
  1656. Hebrew year that starts on Thursday, is `incomplete' (Heshvan and Kislev both
  1657. have 29 days), and has Passover start on Sunday.")
  1658.  
  1659. (defconst hebrew-calendar-year-Thursday-complete-Tuesday
  1660.   [52 nil nil 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22
  1661.     23 24 25 26 27 28 nil 29 30 31 32 33 34 35 36 37 38 39 40 41 42
  1662.     43 44 45 46 47 48 49 [50 51]]
  1663.   "The structure of the parashiot.
  1664. Hebrew year that starts on Thursday, is `complete' (Heshvan and Kislev both
  1665. have 30 days), and has Passover start on Tuesday.")
  1666.  
  1667. (defun hebrew-calendar-parasha-name (p)
  1668.   "Name(s) corresponding to parasha P."
  1669.   (if (arrayp p);; combined parasha
  1670.       (format "%s/%s"
  1671.               (aref hebrew-calendar-parashiot-names (aref p 0))
  1672.               (aref hebrew-calendar-parashiot-names (aref p 1)))
  1673.     (aref hebrew-calendar-parashiot-names p)))
  1674.  
  1675. (defun list-islamic-diary-entries ()
  1676.   "Add any Islamic date entries from the diary file to `diary-entries-list'.
  1677. Islamic date diary entries must be prefaced by an `islamic-diary-entry-symbol'
  1678. (normally an `I').  The same diary date forms govern the style of the Islamic
  1679. calendar entries, except that the Islamic month names must be spelled in full.
  1680. The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
  1681. Dhu al-Hijjah.  If an Islamic date diary entry begins with a
  1682. `diary-nonmarking-symbol', the entry will appear in the diary listing, but will
  1683. not be marked in the calendar.  This function is provided for use with the
  1684. `nongregorian-diary-listing-hook'."
  1685.   (if (< 0 number)
  1686.       (let ((buffer-read-only nil)
  1687.             (diary-modified (buffer-modified-p))
  1688.             (gdate original-date)
  1689.             (mark (regexp-quote diary-nonmarking-symbol)))
  1690.         (calendar-for-loop i from 1 to number do
  1691.            (let* ((d diary-date-forms)
  1692.                   (idate (calendar-islamic-from-absolute 
  1693.                           (calendar-absolute-from-gregorian gdate)))
  1694.                   (month (extract-calendar-month idate))
  1695.                   (day (extract-calendar-day idate))
  1696.                   (year (extract-calendar-year idate)))
  1697.              (while d
  1698.                (let*
  1699.                    ((date-form (if (equal (car (car d)) 'backup)
  1700.                                    (cdr (car d))
  1701.                                  (car d)))
  1702.                     (backup (equal (car (car d)) 'backup))
  1703.                     (dayname
  1704.                      (concat
  1705.                       (calendar-day-name gdate) "\\|"
  1706.                       (substring (calendar-day-name gdate) 0 3) ".?"))
  1707.                     (calendar-month-name-array
  1708.                      calendar-islamic-month-name-array)
  1709.                     (monthname
  1710.                      (concat
  1711.                       "\\*\\|"
  1712.                       (calendar-month-name month)))
  1713.                     (month (concat "\\*\\|0*" (int-to-string month)))
  1714.                     (day (concat "\\*\\|0*" (int-to-string day)))
  1715.                     (year
  1716.                      (concat
  1717.                       "\\*\\|0*" (int-to-string year)
  1718.                       (if abbreviated-calendar-year
  1719.                           (concat "\\|" (int-to-string (% year 100)))
  1720.                         "")))
  1721.                     (regexp
  1722.                      (concat
  1723.                       "\\(\\`\\|\^M\\|\n\\)" mark "?"
  1724.                       (regexp-quote islamic-diary-entry-symbol)
  1725.                       "\\("
  1726.                       (mapconcat 'eval date-form "\\)\\(")
  1727.                       "\\)"))
  1728.                     (case-fold-search t))
  1729.                  (goto-char (point-min))
  1730.                  (while (re-search-forward regexp nil t)
  1731.                    (if backup (re-search-backward "\\<" nil t))
  1732.                    (if (and (or (char-equal (preceding-char) ?\^M)
  1733.                                 (char-equal (preceding-char) ?\n))
  1734.                             (not (looking-at " \\|\^I")))
  1735.                        ;;  Diary entry that consists only of date.
  1736.                        (backward-char 1)
  1737.                      ;;  Found a nonempty diary entry--make it visible and
  1738.                      ;;  add it to the list.
  1739.                      (let ((entry-start (point))
  1740.                            (date-start))
  1741.                        (re-search-backward "\^M\\|\n\\|\\`")
  1742.                        (setq date-start (point))
  1743.                        (re-search-forward "\^M\\|\n" nil t 2)
  1744.                        (while (looking-at " \\|\^I")
  1745.                          (re-search-forward "\^M\\|\n" nil t))
  1746.                        (backward-char 1)
  1747.                        (subst-char-in-region date-start (point) ?\^M ?\n t)
  1748.                        (add-to-diary-list
  1749.                          gdate (buffer-substring entry-start (point)))))))
  1750.                (setq d (cdr d))))
  1751.            (setq gdate
  1752.                  (calendar-gregorian-from-absolute
  1753.                   (1+ (calendar-absolute-from-gregorian gdate)))))
  1754.            (set-buffer-modified-p diary-modified))
  1755.         (goto-char (point-min))))
  1756.  
  1757. (defun mark-islamic-diary-entries ()
  1758.   "Mark days in the calendar window that have Islamic date diary entries.
  1759. Each entry in diary-file (or included files) visible in the calendar window
  1760. is marked.  Islamic date entries are prefaced by a islamic-diary-entry-symbol
  1761. (normally an `I').  The same diary-date-forms govern the style of the Islamic
  1762. calendar entries, except that the Islamic month names must be spelled in full.
  1763. The Islamic months are numbered from 1 to 12 with Muharram being 1 and 12 being
  1764. Dhu al-Hijjah.  Islamic date diary entries that begin with a
  1765. diary-nonmarking-symbol will not be marked in the calendar.  This function is
  1766. provided for use as part of the nongregorian-diary-marking-hook."
  1767.   (let ((d diary-date-forms))
  1768.     (while d
  1769.       (let*
  1770.           ((date-form (if (equal (car (car d)) 'backup)
  1771.                           (cdr (car d))
  1772.                         (car d)));; ignore 'backup directive
  1773.            (dayname (diary-name-pattern calendar-day-name-array))
  1774.            (monthname
  1775.             (concat
  1776.              (diary-name-pattern calendar-islamic-month-name-array t)
  1777.              "\\|\\*"))
  1778.            (month "[0-9]+\\|\\*")
  1779.            (day "[0-9]+\\|\\*")
  1780.            (year "[0-9]+\\|\\*")
  1781.            (l (length date-form))
  1782.            (d-name-pos (- l (length (memq 'dayname date-form))))
  1783.            (d-name-pos (if (/= l d-name-pos) (+ 2 d-name-pos)))
  1784.            (m-name-pos (- l (length (memq 'monthname date-form))))
  1785.            (m-name-pos (if (/= l m-name-pos) (+ 2 m-name-pos)))
  1786.            (d-pos (- l (length (memq 'day date-form))))
  1787.            (d-pos (if (/= l d-pos) (+ 2 d-pos)))
  1788.            (m-pos (- l (length (memq 'month date-form))))
  1789.            (m-pos (if (/= l m-pos) (+ 2 m-pos)))
  1790.            (y-pos (- l (length (memq 'year date-form))))
  1791.            (y-pos (if (/= l y-pos) (+ 2 y-pos)))
  1792.            (regexp
  1793.             (concat
  1794.              "\\(\\`\\|\^M\\|\n\\)"
  1795.              (regexp-quote islamic-diary-entry-symbol)
  1796.              "\\("
  1797.              (mapconcat 'eval date-form "\\)\\(")
  1798.              "\\)"))
  1799.            (case-fold-search t))
  1800.         (goto-char (point-min))
  1801.         (while (re-search-forward regexp nil t)
  1802.           (let* ((dd-name
  1803.                   (if d-name-pos
  1804.                       (buffer-substring
  1805.                        (match-beginning d-name-pos)
  1806.                        (match-end d-name-pos))))
  1807.                  (mm-name
  1808.                   (if m-name-pos
  1809.                       (buffer-substring
  1810.                        (match-beginning m-name-pos)
  1811.                        (match-end m-name-pos))))
  1812.                  (mm (string-to-int
  1813.                       (if m-pos
  1814.                           (buffer-substring
  1815.                            (match-beginning m-pos)
  1816.                            (match-end m-pos))
  1817.                         "")))
  1818.                  (dd (string-to-int
  1819.                       (if d-pos
  1820.                           (buffer-substring
  1821.                            (match-beginning d-pos)
  1822.                            (match-end d-pos))
  1823.                         "")))
  1824.                  (y-str (if y-pos
  1825.                             (buffer-substring
  1826.                              (match-beginning y-pos)
  1827.                              (match-end y-pos))))
  1828.                  (yy (if (not y-str)
  1829.                          0
  1830.                        (if (and (= (length y-str) 2)
  1831.                                 abbreviated-calendar-year)
  1832.                            (let* ((current-y
  1833.                                    (extract-calendar-year
  1834.                                     (calendar-islamic-from-absolute
  1835.                                      (calendar-absolute-from-gregorian
  1836.                                       (calendar-current-date)))))
  1837.                                   (y (+ (string-to-int y-str)
  1838.                                         (* 100 (/ current-y 100)))))
  1839.                              (if (> (- y current-y) 50)
  1840.                                  (- y 100)
  1841.                                (if (> (- current-y y) 50)
  1842.                                    (+ y 100)
  1843.                                  y)))
  1844.                          (string-to-int y-str)))))
  1845.             (if dd-name
  1846.                 (mark-calendar-days-named
  1847.                  (cdr (assoc (capitalize (substring dd-name 0 3))
  1848.                              (calendar-make-alist
  1849.                                calendar-day-name-array
  1850.                                0
  1851.                                '(lambda (x) (substring x 0 3))))))
  1852.               (if mm-name
  1853.                   (if (string-equal mm-name "*")
  1854.                       (setq mm 0)
  1855.                     (setq mm
  1856.                           (cdr (assoc
  1857.                                 (capitalize mm-name)
  1858.                                 (calendar-make-alist
  1859.                                   calendar-islamic-month-name-array))))))
  1860.               (mark-islamic-calendar-date-pattern mm dd yy)))))
  1861.       (setq d (cdr d)))))
  1862.  
  1863. (defun mark-islamic-calendar-date-pattern (month day year)
  1864.   "Mark dates in calendar window that conform to Islamic date MONTH/DAY/YEAR.
  1865. A value of 0 in any position is a wildcard."
  1866.   (save-excursion
  1867.     (set-buffer calendar-buffer)
  1868.     (if (and (/= 0 month) (/= 0 day))
  1869.         (if (/= 0 year)
  1870.             ;; Fully specified Islamic date.
  1871.             (let ((date (calendar-gregorian-from-absolute
  1872.                          (calendar-absolute-from-islamic
  1873.                           (list month day year)))))
  1874.               (if (calendar-date-is-visible-p date)
  1875.                   (mark-visible-calendar-date date)))
  1876.           ;; Month and day in any year--this taken from the holiday stuff.
  1877.           (let* ((islamic-date (calendar-islamic-from-absolute
  1878.                                 (calendar-absolute-from-gregorian
  1879.                                  (list displayed-month 15 displayed-year))))
  1880.                  (m (extract-calendar-month islamic-date))
  1881.                  (y (extract-calendar-year islamic-date))
  1882.                  (date))
  1883.             (if (< m 1)
  1884.                 nil;;   Islamic calendar doesn't apply.
  1885.               (increment-calendar-month m y (- 10 month))
  1886.               (if (> m 7);;  Islamic date might be visible
  1887.                   (let ((date (calendar-gregorian-from-absolute
  1888.                                (calendar-absolute-from-islamic
  1889.                                 (list month day y)))))
  1890.                     (if (calendar-date-is-visible-p date)
  1891.                         (mark-visible-calendar-date date)))))))
  1892.       ;; Not one of the simple cases--check all visible dates for match.
  1893.       ;; Actually, the following code takes care of ALL of the cases, but
  1894.       ;; it's much too slow to be used for the simple (common) cases.
  1895.       (let ((m displayed-month)
  1896.             (y displayed-year)
  1897.             (first-date)
  1898.             (last-date))
  1899.         (increment-calendar-month m y -1)
  1900.         (setq first-date
  1901.               (calendar-absolute-from-gregorian
  1902.                (list m 1 y)))
  1903.         (increment-calendar-month m y 2)
  1904.         (setq last-date
  1905.               (calendar-absolute-from-gregorian
  1906.                (list m (calendar-last-day-of-month m y) y)))
  1907.         (calendar-for-loop date from first-date to last-date do
  1908.           (let* ((i-date (calendar-islamic-from-absolute date))
  1909.                  (i-month (extract-calendar-month i-date))
  1910.                  (i-day (extract-calendar-day i-date))
  1911.                  (i-year (extract-calendar-year i-date)))
  1912.             (and (or (zerop month)
  1913.                      (= month i-month))
  1914.                  (or (zerop day)
  1915.                      (= day i-day))
  1916.                  (or (zerop year)
  1917.                      (= year i-year))
  1918.                  (mark-visible-calendar-date
  1919.                   (calendar-gregorian-from-absolute date)))))))))
  1920.  
  1921. (provide 'diary)
  1922.  
  1923. ;;; diary.el ends here
  1924.